home *** CD-ROM | disk | FTP | other *** search
/ Software Vault: The Gold Collection / Software Vault - The Gold Collection (American Databankers) (1993).ISO / cdr21 / lensca.zip / LENSCAD.BAS next >
BASIC Source File  |  1993-05-31  |  25KB  |  900 lines
  1. '
  2. '
  3. '                    ┌────────────────────────┐
  4. '                    │   LensCAD Version 1.0  │
  5. '                    │   Copyright c1993      │
  6. '                    │   James M. Michael     │
  7. '                    │   P.O. Box 941124      │
  8. '                    │   Atlanta, GA 30314    │
  9. '                    └────────────────────────┘
  10. '
  11. 'This source code is provided on an AS IS basis for personal use only.
  12. 'ANY other use of this code is in violation of the copyright. Don't even
  13. 'think of using this in a commercial product without getting written
  14. 'authorization first. You may alter this code as you see fit for your
  15. 'personal use and such hacking is encouraged. I have tried to include
  16. 'code that will enrage even the most laid back hacker, including the
  17. 'dreaded GOTO command. This program was created for designing multilens
  18. 'optical systems and is written in QB45. If you want to use this program 
  19. 'to design an optical system which employs mirrors, you will have to 
  20. 'figure out how to make it work. This program has a minimal amount of 
  21. 'comments. It should be easy to figure out how it works.  Since the 
  22. 'program is offered free of charge for personal use, there is no support
  23. 'offered. If you need more information or if you find the program useful
  24. 'and choose to support it, you may send $20 in US funds for the latest
  25. 'version of the code alond with additional technical information and 
  26. 'references. There is no way to guarantee that the source code document 
  27. 'you are currently reading has not been corrupted. 
  28. '
  29. '
  30. 'Begin Code Segment: Declare some subs
  31.  
  32.  
  33. DECLARE SUB matrixcalc ()
  34. DECLARE SUB setoption ()
  35. DECLARE SUB menu ()
  36. DECLARE SUB changecolors ()
  37. DECLARE SUB makereport ()
  38. DECLARE SUB setinput ()
  39. DECLARE SUB optionmenu ()
  40. DECLARE SUB savestuff ()
  41. DECLARE SUB setcurv ()
  42. DECLARE SUB setindex ()
  43. DECLARE SUB review ()
  44. DECLARE SUB matassign ()
  45. DECLARE SUB getstuff ()
  46. DECLARE SUB lensindex ()
  47. DECLARE SUB lensspace ()
  48. DECLARE SUB lensthick ()
  49. DECLARE SUB spaceindex ()
  50. DECLARE SUB setinindex ()
  51. DECLARE SUB setoutindex ()
  52. CLEAR , , 3000                 'set stack size to 3000
  53. CLS
  54. LOCATE 10, 1
  55. INPUT " Do you wish to use the old data(y/n) :", y$    'if yes better have a file
  56. IF UCASE$(y$) = "Y" THEN
  57.     yes = 1
  58.     INPUT "File from which to retrieve data: ", filename$     'it better exist or you will crash
  59.     CLS
  60.     LOCATE 15, 15
  61.     PRINT "Searching..."
  62.     OPEN filename$ FOR INPUT AS #1
  63.     INPUT #1, ne, nm, nr, nd, nn, colors, nvm
  64.     CLOSE #1
  65. ELSE
  66.     CLS
  67.     yes = 0
  68.     LOCATE 10, 10
  69.     INPUT "How many lens elements: ", ne          ' ne is the number of lens elements
  70.     nr = ne * 2                                   ' nr is the number of surfaces
  71.     nd = ne * 2 - 1                               ' nd is the number of distances
  72.     nn = ne * 2 + 1                               ' nn is the number of indices of refraction
  73.     nm = ne * 4 - 1                               ' nm is the number of matrices
  74. END IF
  75. DIM SHARED r(nr, 0 TO 100) AS DOUBLE              'dimension some arrays
  76. DIM SHARED d(nd, 0 TO 100) AS DOUBLE
  77. DIM SHARED rinc(nr) AS SINGLE
  78. DIM SHARED dinc(nd) AS SINGLE
  79. DIM SHARED rpts(nr) AS INTEGER
  80. DIM SHARED dpts(nd) AS INTEGER
  81. DIM SHARED m(nm, 2, 2) AS DOUBLE
  82. DIM SHARED p(nm, 2, 2) AS DOUBLE
  83. DIM SHARED inmatrix(2) AS DOUBLE
  84. DIM SHARED outmatrix(2) AS DOUBLE
  85. DIM SHARED rpt(nr) AS INTEGER
  86. DIM SHARED dpt(nd) AS INTEGER
  87. DIM SHARED n1(0 TO nn - 1) AS DOUBLE
  88. DIM SHARED rr(nr) AS DOUBLE
  89. DIM SHARED dd(nd) AS DOUBLE
  90. DIM SHARED mn(3) AS INTEGER
  91. CLS
  92. IF yes = 0 THEN
  93.     FOR i = 1 TO nr
  94.         rpts(i) = 1
  95.     NEXT i
  96.     FOR i = 1 TO nd
  97.         dpts(i) = 1
  98.     NEXT i
  99.  
  100.     LOCATE 10, 1
  101.     PRINT "     You have four options to look at the effects of changes"
  102.     PRINT "     of parameters on lens designs. You may look at one"
  103.     PRINT "     parameter over 100 points and up to 3 wavelengths, 2"
  104.     PRINT "     parameters over 10 points each and up to 3 wavelengths,"
  105.     PRINT "     or 3 parameters over 10 points each and up to 3 wavelengths."
  106.     PRINT "     You may also keep all parameters constant and look at up to"
  107.     PRINT "     3 wavelengths."
  108.     PRINT ""
  109.     PRINT ""
  110.     PRINT "Press a key to begin."
  111.     DO WHILE INKEY$ = "": LOOP
  112.     CLS
  113.     LOCATE 10, 5
  114.     PRINT "Choose Option:"
  115.     LOCATE 12, 1
  116.     PRINT "0> Make all parameters constant"
  117.     PRINT "1> Look at one parameter over 100 points"
  118.     PRINT "2> Vary two parameters over 10 points each"
  119.     PRINT "3> Look at three parameters over 10 points each"
  120.     PRINT ""
  121.     INPUT "Choice: ", nvm
  122.     CALL setoption
  123.     CLS
  124.     LOCATE 10, 5
  125. 100 PRINT "You may choose up to 3 wavelengths of light."
  126.     LOCATE 11, 5
  127.     INPUT "Number of wavelengths to use: ", colors
  128.     IF colors > 3 OR colors < 1 THEN GOTO 100
  129. END IF
  130. DIM SHARED lambda(3) AS DOUBLE
  131. IF yes = 0 THEN
  132. FOR i = 1 TO colors
  133. 200 CLS
  134.     LOCATE 10, 1
  135.     PRINT "Choose a color or enter your own wavelength:"
  136.     PRINT ""
  137.     PRINT "1> RED"
  138.     PRINT "2> YELLOW"
  139.     PRINT "3> BLUE"
  140.     PRINT "4> Enter Wavelength"
  141.     PRINT ""
  142.     INPUT "Choice: ", c
  143.     SELECT CASE c
  144.         CASE 1
  145.             lambda(i) = 656.3 * 10 ^ -9
  146.         CASE 2
  147.             lambda(i) = 589.3 * 10 ^ -9
  148.         CASE 3
  149.             lambda(i) = 486.1 * 10 ^ -9
  150.         CASE 4
  151.             INPUT "Wavelength (meters): ", lambda(i)
  152.         CASE ELSE
  153.             GOTO 200
  154.     END SELECT
  155. NEXT i
  156. END IF
  157. DIM SHARED n(0 TO nn, colors) AS DOUBLE
  158. FOR i = 1 TO colors
  159.     IF n(0, i) = 0 THEN n(0, i) = 1.0003
  160.     IF n(nn - 1, i) = 0 THEN n(nn - 1, i) = 1.0003
  161. NEXT i
  162. IF UCASE$(y$) = "Y" THEN CALL getstuff
  163. CALL menu
  164.  
  165. SUB changecolors
  166. CLS
  167. LOCATE 10, 1
  168. PRINT "If you change data here you must reenter all index of refraction"
  169. PRINT "data. Enter c to continue with data change. Press another key to"
  170. PRINT "abort data change."
  171. PRINT ""
  172. DO
  173. test$ = INKEY$
  174. LOOP WHILE UCASE$(test$) = ""
  175. IF UCASE$(test$) = "C" THEN
  176.     CLS
  177.     LOCATE 10, 5
  178. 300 PRINT "You may choose up to 3 wavelengths of light."
  179.     LOCATE 11, 5
  180.     INPUT "Number of wavelengths to use: ", colors
  181.     IF colors > 3 OR colors < 1 THEN GOTO 300
  182.     FOR i = 1 TO colors
  183. 400     CLS
  184.         LOCATE 10, 1
  185.         PRINT "Choose a color or enter your own wavelength:"
  186.         PRINT ""
  187.         PRINT "1> RED"
  188.         PRINT "2> YELLOW"
  189.         PRINT "3> BLUE"
  190.         PRINT "4> Enter Wavelength"
  191.         PRINT ""
  192.         INPUT "Choice: ", c
  193.         SELECT CASE c
  194.             CASE 1
  195.                 lambda(i) = 656.3 * 10 ^ -9
  196.             CASE 2
  197.                 lambda(i) = 589.3 * 10 ^ -9
  198.             CASE 3
  199.                 lambda(i) = 486.1 * 10 ^ -9
  200.             CASE 4
  201.                 INPUT "Wavelength (meters): ", lambda(i)
  202.             CASE ELSE
  203.                 GOTO 400
  204.         END SELECT
  205.     NEXT i
  206. END IF
  207. END SUB
  208.  
  209. SUB getstuff
  210. SHARED ne, nm, nr, nd, nn, colors, nvm, filename$
  211. OPEN filename$ FOR INPUT AS #1
  212. INPUT #1, ne, nm, nr, nd, nn, colors, nvm
  213. FOR i = 1 TO nr
  214.     INPUT #1, rpts(i)
  215.     FOR j = 0 TO rpts(i) - 1
  216.         INPUT #1, r(i, j)
  217.     NEXT j
  218. NEXT i
  219. FOR i = 1 TO nd
  220.     INPUT #1, dpts(i)
  221.     FOR j = 0 TO dpts(i) - 1
  222.         INPUT #1, d(i, j)
  223.     NEXT j
  224. NEXT i
  225. FOR i = 0 TO nn - 1
  226.     FOR j = 1 TO colors
  227.         INPUT #1, n(i, j)
  228.     NEXT j
  229. NEXT i
  230. FOR i = 1 TO colors
  231.     INPUT #1, lambda(i)
  232. NEXT i
  233. CLOSE #1
  234. END SUB
  235.  
  236. SUB lensindex
  237. CLS
  238. SHARED colors, ne
  239. LOCATE 10, 1
  240. DO WHILE we < 1 OR we > ne
  241.     INPUT "Which element: ", we
  242. LOOP
  243. wn = 2 * we - 1
  244. PRINT "Choose glass type:"
  245. PRINT ""
  246. PRINT ""
  247. PRINT "1> BK 7"
  248. PRINT "2> SF 11"
  249. PRINT "3> LaSF 9"
  250. PRINT "4> OTHER"
  251. PRINT ""
  252. 1000 INPUT "Choice: ", n
  253. SELECT CASE n
  254.     CASE 1
  255.         a0 = 2.2718929#
  256.         a1 = -1.0108077# * 10 ^ -2
  257.         a2 = 1.0592509# * 10 ^ -2
  258.         a3 = 2.0816965# * 10 ^ -4
  259.         a4 = -7.6472538# * 10 ^ -6
  260.         a5 = 4.9240991# * 10 ^ -7
  261.     CASE 2
  262.         a0 = 3.0539614#
  263.         a1 = -1.1580432# * 10 ^ -2
  264.         a2 = 3.9199816# * 10 ^ -2
  265.         a3 = 2.9462812# * 10 ^ -3
  266.         a4 = -2.0371019# * 10 ^ -4
  267.         a5 = 2.7633569# * 10 ^ -5
  268.     CASE 3
  269.         a0 = 3.305183#
  270.         a1 = -1.3857059# * 10 ^ -2
  271.         a2 = 3.5921736# * 10 ^ -2
  272.         a3 = 2.6740381# * 10 ^ -3
  273.         a4 = -1.9764177# * 10 ^ -4
  274.         a5 = 1.9381052# * 10 ^ -5
  275.     CASE 4
  276.         FOR i = 1 TO colors
  277.             CLS
  278.             LOCATE 10, 5
  279.             PRINT "Enter index of refraction at "; lambda(i); " meters:"; : INPUT "", n(wn, i)
  280.         NEXT i
  281.     CASE ELSE
  282.         CALL lensindex
  283. END SELECT
  284. IF n < 4 THEN
  285.     FOR i = 1 TO colors
  286.         L = lambda(i) * 10 ^ 6
  287.         n(wn, i) = SQR(a0 + a1 * L * L + a2 / (L * L) + a3 * (L ^ -4) + a4 * (L ^ -6) + a5 * (L ^ -8))
  288.     NEXT i
  289. END IF
  290. END SUB
  291.  
  292. SUB lensspace
  293. CLS
  294. SHARED ne
  295. LOCATE 10, 1
  296. DO WHILE we > ne OR we < 1
  297.     INPUT "Greatest element number adjoining space: ", we
  298. LOOP
  299. wd = we * 2 - 2
  300. IF dpts(wd) = 1 THEN INPUT "Distance: ", d(wd, 0)
  301. IF dpts(wd) > 1 THEN
  302.     INPUT "Distance range (low,high): ", d(wd, 0), d(wd, dpts(wd) - 1)
  303.     dinc(wd) = (d(wd, dpts(wd) - 1) - d(wd, 0)) / (dpts(wd) - 1)
  304.     FOR i = 1 TO dpts(wd) - 2
  305.         d(wd, i) = d(wd, i - 1) + dinc(wd)
  306.     NEXT i
  307. END IF
  308. END SUB
  309.  
  310. SUB lensthick
  311. CLS
  312. SHARED ne
  313. LOCATE 10, 1
  314. DO WHILE we > ne OR we < 1
  315.     INPUT "Which element: ", we
  316. LOOP
  317. wd = we * 2 - 1
  318. IF dpts(wd) = 1 THEN INPUT "Thickness: ", d(wd, 0)
  319. IF dpts(wd) > 1 THEN
  320.     INPUT "Thickness range (low,high): ", d(wd, 0), d(wd, dpts(wd) - 1)
  321.     dinc(wd) = (d(wd, dpts(wd) - 1) - d(wd, 0)) / (dpts(wd) - 1)
  322.     FOR i = 1 TO dpts(wd) - 2
  323.         d(wd, i) = d(wd, i - 1) + dinc(wd)
  324.     NEXT i
  325. END IF
  326. END SUB
  327.  
  328. SUB makereport
  329. SHARED ne, nm, nr, nd, nn, colors
  330. INPUT "File to write report to: ", filename$
  331. OPEN filename$ FOR OUTPUT AS #3
  332. INPUT "Title of Report: ", title$
  333. PRINT #3, title$
  334. PRINT #3, " "
  335. FOR i = 1 TO nr
  336.     PRINT #3, "Curvature Range "; i; "="; r(i, 0); " to "; r(i, rpts(i) - 1)
  337. NEXT i
  338. FOR i = 1 TO nd STEP 2
  339.         PRINT #3, "Thickness Range Element "; (i + 1) / 2; "="; d(i, 0); " to "; d(i, dpts(i) - 1)
  340. NEXT i
  341. FOR i = 2 TO nd - 1 STEP 2
  342.     PRINT #3, "Space Element "; (i + 2) / 2; " to "; ((i + 2) / 2) - 1; "="; d(i, 0); " to "; d(i, dpts(i) - 1)
  343. NEXT i
  344. FOR i = 1 TO ne
  345.     FOR j = 1 TO colors
  346.         PRINT #3, "Element "; i; " Index at "; lambda(j); " meters ="; n(i * 2 - 1, j)
  347.     NEXT j
  348. NEXT i
  349. FOR i = 0 TO nn - 3 STEP 2
  350.     PRINT #3, "Index before element "; (i + 2) / 2; "="; n(i, 1)
  351. NEXT i
  352. PRINT #3, "Index after element "; ne; "="; n(nn - 1, 1)
  353. CLOSE #3
  354. END SUB
  355.  
  356. SUB matassign
  357. IF inmatrix(1) = 0 AND inmatrix(2) = 0 THEN CALL setinput
  358. SHARED nm, colors, nvm, nd, nr, nn
  359. CLS
  360. LOCATE 10
  361. INPUT "File to store output: ", outfile$
  362. OPEN outfile$ FOR OUTPUT AS #1
  363. FOR i = 1 TO nr
  364.     rr(i) = r(i, 0)
  365. NEXT i
  366. FOR i = 1 TO nd
  367.     IF d(i, 0) = 0 THEN d(i, 0) = .000001   'Some separation of elements required
  368.     dd(i) = d(i, 0)
  369. NEXT i
  370. FOR ni = 0 TO colors - 1
  371.     FOR i = 0 TO nn - 1
  372.         IF n(i, 1) = 0 THEN
  373.             CLS
  374.             LOCATE 10
  375.             PRINT "Fatal Error. Index of Refraction N("; i; ")=0"
  376.             PRINT "Press a key to change index and continue..."
  377.             DO WHILE INKEY$ = ""
  378.             LOOP
  379.             CALL setindex
  380.         END IF
  381.         n1(i) = n(i, 1 + ni)
  382.     NEXT i
  383.     IF nvm = 0 THEN CALL matrixcalc
  384.     IF nvm = 1 THEN
  385.         FOR ii = 0 TO 100
  386.         FOR jj = 1 TO nm STEP 2
  387.             wr = (jj + 1) / 2
  388.             wd = (jj - 1) / 2
  389.             wn = wd
  390.             IF rpts(wr) > 1 THEN
  391.                 rr(wr) = r(wr, ii)
  392.                 WRITE #1, lambda(1 + ni), rr(wr)
  393.             ELSEIF dpts(wd) > 1 THEN
  394.                 dd(wd) = d(wd, ii)
  395.                 WRITE #1, lambda(ni + 1), dd(wd)
  396.             END IF
  397.         NEXT jj
  398.         CALL matrixcalc
  399.     NEXT ii
  400. ELSEIF nvm = 2 THEN
  401.     FOR i = 0 TO 10
  402.         FOR j = 0 TO 10
  403.             count = 1
  404.             FOR k = 1 TO nm STEP 2
  405.                 wr = (k + 1) / 2
  406.                 wd = (k - 1) / 2
  407.                 IF rpts(wr) > 1 THEN
  408.                     SELECT CASE count
  409.                         CASE 1
  410.                             rr(wr) = r(wr, j)
  411.                             WRITE #1, lambda(ni + 1), rr(wr)
  412.                             count = count + 1
  413.                         CASE 2
  414.                             rr(wr) = r(wr, i)
  415.                             WRITE #1, lambda(ni + 1), rr(wr)
  416.                     END SELECT
  417.                 END IF
  418.                 IF dpts(wd) > 1 THEN
  419.                     SELECT CASE count
  420.                         CASE 1
  421.                             dd(wd) = d(wd, j)
  422.                             WRITE #1, lambda(ni + 1), dd(wd)
  423.                             count = count + 1
  424.                         CASE 2
  425.                             dd(wd) = d(wd, i)
  426.                             WRITE #1, lambda(ni + 1), dd(wd)
  427.                     END SELECT
  428.                 END IF
  429.             NEXT k
  430.             CALL matrixcalc
  431.         NEXT j
  432.     NEXT i
  433. ELSEIF nvm = 3 THEN
  434.     FOR ii = 0 TO 10
  435.         FOR jj = 0 TO 10
  436.             FOR kk = 0 TO 10
  437.                 count = 1
  438.                 FOR k = 1 TO nm STEP 2
  439.                     wr = (k + 1) / 2
  440.                     wd = (k - 1) / 2
  441.                     IF rpts(wr) > 1 THEN
  442.                         SELECT CASE count
  443.                             CASE 1
  444.                                 rr(wr) = r(wr, kk)
  445.                                 WRITE #1, lambda(ni + 1), rr(wr)
  446.                                 count = count + 1
  447.                             CASE 2
  448.                                 rr(wr) = r(wr, jj)
  449.                                 WRITE #1, lambda(ni + 1), rr(wr)
  450.                                 count = count + 1
  451.                             CASE 3
  452.                                 rr(wr) = r(wr, ii)
  453.                                 WRITE #1, lambda(ni + 1), rr(wr)
  454.                         END SELECT
  455.                     END IF
  456.                     IF dpts(wd) > 1 THEN
  457.                         SELECT CASE count
  458.                             CASE 1
  459.                                 dd(wd) = d(wd, kk)
  460.                                 WRITE #1, lambda(ni + 1), dd(wd)
  461.                                 count = count + 1
  462.                             CASE 2
  463.                                 dd(wd) = d(wd, jj)
  464.                                 WRITE #1, lambda(ni + 1), dd(wd)
  465.                                 count = count + 1
  466.                             CASE 3
  467.                                 dd(wd) = d(wd, ii)
  468.                                 WRITE #1, lambda(ni + 1), dd(wd)
  469.                         END SELECT
  470.                     END IF
  471.                 NEXT k
  472.                 CALL matrixcalc
  473.             NEXT kk
  474.         NEXT jj
  475.     NEXT ii
  476. END IF
  477. NEXT ni
  478. CLOSE #1
  479. END SUB
  480.  
  481. SUB matrixcalc
  482. SHARED nm, nn, focaldist
  483. k = 0
  484. FOR i = 1 TO nm STEP 2
  485.     m(i, 1, 2) = (n1(i - k) - n1(i - k - 1)) / rr(i - k)
  486.     k = k + 1
  487.     m(i, 1, 1) = 1
  488.     m(i, 2, 1) = 0
  489.     m(i, 2, 2) = 1
  490. NEXT i
  491. FOR j = 2 TO nm - 1 STEP 2
  492.     m(j, 2, 1) = (-dd(j / 2)) / n1(j / 2)
  493.     m(j, 1, 1) = 1
  494.     m(j, 1, 2) = 0
  495.     m(j, 2, 2) = 1
  496. NEXT j
  497. FOR i = 1 TO 2
  498.     FOR j = 1 TO 2
  499.         p(1, i, j) = m(1, i, j)
  500.     NEXT j
  501. NEXT i
  502. FOR i = 2 TO nm
  503.     p(i, 1, 1) = m(i, 1, 1) * p(i - 1, 1, 1) + m(i, 1, 2) * p(i - 1, 2, 1)
  504.     p(i, 1, 2) = m(i, 1, 1) * p(i - 1, 1, 2) + m(i, 1, 2) * p(i - 1, 2, 2)
  505.     p(i, 2, 1) = m(i, 2, 1) * p(i - 1, 1, 1) + m(i, 2, 2) * p(i - 1, 2, 1)
  506.     p(i, 2, 2) = m(i, 2, 1) * p(i - 1, 1, 2) + m(i, 2, 2) * p(i - 1, 2, 2)
  507. NEXT i
  508. CLS
  509. LOCATE 10, 1
  510. FOR i = 1 TO 2
  511.     FOR j = 1 TO 2
  512.         PRINT "System("; i; ","; j; ")="; p(nm, i, j)
  513.     NEXT j
  514. NEXT i
  515. PRINT "Determinant of system matrix="; p(nm, 1, 1) * p(nm, 2, 2) - p(nm, 2, 1) * p(nm, 1, 2)
  516. outmatrix(1) = p(nm, 1, 1) * inmatrix(1) + p(nm, 1, 2) * inmatrix(2)
  517. outmatrix(2) = p(nm, 2, 1) * inmatrix(1) + p(nm, 2, 2) * inmatrix(2)
  518. focaldist = outmatrix(2) / outmatrix(1)
  519. WRITE #1, focaldist
  520. END SUB
  521.  
  522. SUB menu
  523. CLS
  524. LOCATE 4, 1
  525. PRINT "         Main Menu:"
  526. PRINT "         "
  527. PRINT "         1> Set Curvature"
  528. PRINT "         2> Set Element Thickness"
  529. PRINT "         3> Set Element Spacing"
  530. PRINT "         4> Set Index of Refraction"
  531. PRINT "         5> Review Design Parameters"
  532. PRINT "         6> Calculate Focal Distance"
  533. PRINT "         7> Change Options"
  534. PRINT "         8> Save Design Parameters"
  535. PRINT "         9> Set Input To System"
  536. PRINT "        10> Change Wavelength Size or Number"
  537. PRINT "        11> Make Report on Current Design "
  538. PRINT "        12> Quit "
  539. PRINT "         "
  540. INPUT "         Selection: ", s
  541. SELECT CASE s
  542.     CASE 1
  543.         CALL setcurv
  544.         CALL menu
  545.     CASE 2
  546.         CALL lensthick
  547.         CALL menu
  548.     CASE 3
  549.         CALL lensspace
  550.         CALL menu
  551.     CASE 4
  552.         CALL setindex
  553.         CALL menu
  554.     CASE 5
  555.         CALL review
  556.         CALL menu
  557.     CASE 6
  558.         CALL matassign
  559.         CALL menu
  560.     CASE 7
  561.         CALL optionmenu
  562.         CALL menu
  563.     CASE 8
  564.         CALL savestuff
  565.         CALL menu
  566.     CASE 9
  567.         CALL setinput
  568.         CALL menu
  569.     CASE 10
  570.         CALL changecolors
  571.         CALL menu
  572.     CASE 11
  573.         CALL makereport
  574.         CALL menu
  575.     CASE 12
  576.         END
  577.     CASE ELSE
  578.         CALL menu
  579. END SELECT
  580. END SUB
  581.  
  582. SUB optionmenu
  583. CLS
  584. SHARED nvm
  585. LOCATE 10, 1
  586. PRINT "Choose Option:"
  587. PRINT " "
  588. PRINT "0> Make all parameters constant"
  589. PRINT "1> Look at one parameter over 100 points"
  590. PRINT "2> Vary two parameters over 10 points each"
  591. PRINT "3> Look at three parameters over 10 points each"
  592. PRINT ""
  593. INPUT "Choice: ", nvm
  594. IF nvm > 3 OR nvm < 0 THEN CALL optionmenu
  595. CALL setoption
  596. END SUB
  597.  
  598. SUB review
  599. SHARED ne, colors, nn, nvm
  600. CLS
  601. PRINT "The index or refraction of the medium before element 1 is "; n(0, 1)
  602. PRINT "The index of refraction of the medium after element "; ne; " is "; n(nn - 1, 1)
  603. PRINT "The number of variable parameters is set at "; nvm
  604. FOR i = 1 TO ne
  605.     LOCATE 5, 1
  606.     PRINT "Element #"; i
  607.     PRINT "Curvature range surface 1="; r(i * 2 - 1, 0); " to "; r(i * 2 - 1, rpts(i * 2 - 1) - 1)
  608.     PRINT "Increment="; rinc(i * 2 - 1)
  609.     PRINT "Curvature range surface 2="; r(i * 2, 0); " to "; r(i * 2, rpts(i * 2) - 1)
  610.     PRINT "Increment="; rinc(i * 2)
  611.     PRINT ""
  612.     PRINT "Thickness range="; d(i * 2 - 1, 0); " to "; d(i * 2 - 1, dpts(i * 2 - 1) - 1)
  613.     PRINT "Increment="; dinc(i * 2 - 1)
  614.     FOR j = 1 TO colors
  615.         PRINT "N("; lambda(j); ")="; n(2 * i - 1, j)
  616.     NEXT j
  617.     PRINT " "
  618.     PRINT "Press a key for next parameter..."
  619.     DO WHILE INKEY$ = "": LOOP
  620.     CLS
  621.     IF i < ne THEN
  622.         LOCATE 5, 1
  623.         PRINT "Space range between elements "; i; " and "; i + 1; "="; d(i * 2, 0); " to "; d(i * 2, dpts(i * 2) - 1)
  624.         PRINT "Increment="; dinc(i * 2)
  625.         PRINT "N="; n(2 * i, 1)
  626.         PRINT ""
  627.         PRINT "Press a key..."
  628.         DO WHILE INKEY$ = ""
  629.         LOOP
  630.         CLS
  631.     END IF
  632. NEXT i
  633. END SUB
  634.  
  635. SUB savestuff
  636. SHARED ne, nm, nr, nd, nn, colors, nvm
  637. INPUT "Name of file in which to store data: ", filename$
  638. OPEN filename$ FOR OUTPUT AS #1
  639. WRITE #1, ne, nm, nr, nd, nn, colors, nvm
  640. FOR i = 1 TO nr
  641.     WRITE #1, rpts(i)
  642.     FOR j = 0 TO rpts(i) - 1
  643.         WRITE #1, r(i, j)
  644.     NEXT j
  645. NEXT i
  646. FOR i = 1 TO nd
  647.     WRITE #1, dpts(i)
  648.     FOR j = 0 TO dpts(i) - 1
  649.         WRITE #1, d(i, j)
  650.     NEXT j
  651. NEXT i
  652. FOR i = 0 TO nn - 1
  653.     FOR j = 1 TO colors
  654.         WRITE #1, n(i, j)
  655.     NEXT j
  656. NEXT i
  657. FOR i = 1 TO colors
  658.     WRITE #1, lambda(i)
  659. NEXT i
  660. CLOSE #1
  661. END SUB
  662.  
  663. SUB setcurv
  664. CLS
  665. LOCATE 10, 1
  666. SHARED ne
  667. DO WHILE we > ne OR we < 1
  668.     INPUT "Which element: ", we
  669. LOOP
  670. DO WHILE ws > 2 OR ws < 1
  671. INPUT "Which surface: ", ws
  672. LOOP
  673. wr = we * 2 - 2 + ws
  674. IF rpts(wr) = 1 THEN INPUT "Curvature: ", r(wr, 0)
  675. IF rpts(wr) > 1 THEN
  676.     INPUT "Curvature range (low,high): ", r(wr, 0), r(wr, rpts(wr) - 1)
  677.     rinc(wr) = (r(wr, rpts(wr) - 1) - r(wr, 0)) / (rpts(wr) - 1)
  678.     FOR i = 1 TO rpts(wr) - 2
  679.         r(wr, i) = r(wr, i - 1) + rinc(wr)
  680.     NEXT i
  681. END IF
  682. END SUB
  683.  
  684. SUB setdistance
  685. CLS
  686. LOCATE 10, 1
  687. PRINT "Choose distance to set:"
  688. PRINT ""
  689. PRINT "1> Lens thickness"
  690. PRINT "2> Lens spacing"
  691. PRINT ""
  692. INPUT "Choice: ", n
  693. IF n = 1 THEN CALL lensthick
  694. IF n = 2 THEN CALL lensspace
  695. END SUB
  696.  
  697. SUB setindex
  698. CLS
  699. LOCATE 10, 1
  700. PRINT "Choose index to set:"
  701. PRINT ""
  702. PRINT "1> Lens element"
  703. PRINT "2> Lens spacing"
  704. PRINT "3> Input"
  705. PRINT "4> Output"
  706. PRINT ""
  707. INPUT "Choice: ", m
  708. IF m = 1 THEN CALL lensindex
  709. IF m = 2 THEN CALL spaceindex
  710. IF m = 3 THEN CALL setinindex
  711. IF m = 4 THEN CALL setoutindex
  712. IF m > 4 OR m < 1 THEN CALL setindex
  713. END SUB
  714.  
  715. SUB setinindex
  716. SHARED colors
  717. CLS
  718. LOCATE 10, 1
  719. PRINT "Choose medium at input:"
  720. PRINT ""
  721. PRINT "1> Air"
  722. PRINT "2> Vacuum"
  723. PRINT "3> Water"
  724. PRINT "4> Other"
  725. PRINT ""
  726. INPUT "Choice: ", L
  727. SELECT CASE L
  728.     CASE 1
  729.         n = 1.0003
  730.     CASE 2
  731.         n = 1!
  732.     CASE 3
  733.         n = 4 / 3
  734.     CASE 4
  735.         INPUT "Index of refraction: ", n
  736.     CASE ELSE
  737.         CALL setinindex
  738. END SELECT
  739. FOR i = 1 TO colors
  740.     n(0, i) = n
  741. NEXT i
  742. END SUB
  743.  
  744. SUB setinput
  745. CLS
  746. LOCATE 10, 1
  747. INPUT "Angle ray to subtend with optical axis (radians): ", gamma
  748. INPUT "Height above axis (meters): ", h
  749. inmatrix(1) = n(0, 1) * gamma
  750. inmatrix(2) = h
  751. END SUB
  752.  
  753. SUB setoption
  754. SHARED nvm, ne, nr, nd
  755. FOR i = 1 TO nr
  756.     rpts(i) = 1
  757. NEXT i
  758. FOR i = 1 TO nd
  759.     dpts(i) = 1
  760. NEXT i
  761. IF nvm = 0 THEN EXIT SUB
  762. FOR i = 1 TO nvm
  763.     c = 0
  764.     we = 0
  765.     ws = 0
  766.     CLS
  767.     PRINT ""
  768.     LOCATE 10
  769.     PRINT "Select Parameter To Vary:"
  770.     PRINT ""
  771.     PRINT "     1> Curvature"
  772.     PRINT "     2> Element Thickness"
  773.     PRINT "     3> Element Spacing"
  774.     PRINT " "
  775.     INPUT "Choice: ", c
  776.     SELECT CASE c
  777.         CASE 1
  778.             CLS
  779.             LOCATE 10
  780.             DO WHILE we > ne OR we < 1
  781.                 INPUT "Which element: ", we
  782.             LOOP
  783.             DO WHILE ws > 2 OR ws < 1
  784.                 INPUT "Which surface (1 or 2):", ws
  785.             LOOP
  786.             wr = we * 2 - 2 + ws
  787.             mn(i) = wr * 2 - 1
  788.             IF nvm = 1 THEN rpts(wr) = 101
  789.             IF nvm = 2 THEN rpts(wr) = 11
  790.             IF nvm = 3 THEN rpts(wr) = 11
  791.             INPUT "Curvature range (low,high)", r(wr, 0), r(wr, rpts(wr) - 1)
  792.             rinc(wr) = (r(wr, rpts(wr) - 1) - r(wr, 0)) / (rpts(wr) - 1)
  793.             FOR j = 1 TO rpts(wr) - 2
  794.                 r(wr, j) = r(wr, j - 1) + rinc(wr)
  795.             NEXT j
  796.         CASE 2
  797.             CLS
  798.             LOCATE 10
  799.             we = 0
  800.             DO WHILE we > ne OR we < 1
  801.             INPUT "Thickness of which element: ", we
  802.             LOOP
  803.             wd = we * 2 - 1
  804.             mn(i) = 2 * wd
  805.             IF nvm = 1 THEN dpts(wd) = 101
  806.             IF nvm = 2 THEN dpts(wd) = 11
  807.             IF nvm = 3 THEN dpts(wd) = 11
  808.             INPUT "Thickness Range (low,high): ", d(wd, 0), d(wd, dpts(wd) - 1)
  809.             dinc(wd) = (d(wd, dpts(wd) - 1) - d(wd, 0)) / (dpts(wd) - 1)
  810.             FOR j = 1 TO dpts(wd) - 2
  811.                 d(wd, j) = d(wd, j - 1) + dinc(wd)
  812.             NEXT j
  813.         CASE 3
  814.             CLS
  815.             LOCATE 10
  816.             we = 0
  817.             DO WHILE we < 1 OR we > ne
  818.                 INPUT "Highest number element adjoining this space: ", we
  819.             LOOP
  820.             wd = 2 * we - 2
  821.             mn(i) = wd * 2
  822.             IF nvm = 1 THEN dpts(wd) = 101
  823.             IF nvm = 2 THEN dpts(wd) = 11
  824.             IF nvm = 3 THEN dpts(wd) = 11
  825.             INPUT "Distance Range (low,high): ", d(wd, 0), d(wd, dpts(wd) - 1)
  826.             dinc(wd) = (d(wd, dpts(wd) - 1) - d(wd, 0)) / (dpts(wd) - 1)
  827.             FOR j = 1 TO dpts(wd) - 2
  828.                 d(wd, j) = d(wd, j - 1) + dinc(wd)
  829.             NEXT j
  830.         CASE ELSE
  831.             CALL optionmenu
  832.     END SELECT
  833. NEXT i
  834. END SUB
  835.  
  836. SUB setoutindex
  837. SHARED colors, nn
  838. CLS
  839. LOCATE 10, 1
  840. PRINT "Choose medium at output:"
  841. PRINT ""
  842. PRINT "1> Air"
  843. PRINT "2> Vacuum"
  844. PRINT "3> Water"
  845. PRINT "4> Other"
  846. PRINT ""
  847. INPUT "Choice: ", L
  848. SELECT CASE L
  849.     CASE 1
  850.         n = 1.0003
  851.     CASE 2
  852.         n = 1!
  853.     CASE 3
  854.         n = 4 / 3
  855.     CASE 4
  856.         INPUT "Index of refraction: ", n
  857.     CASE ELSE
  858.         CALL setoutindex
  859. END SELECT
  860. FOR i = 1 TO colors
  861.     n(nn - 1, i) = n
  862. NEXT i
  863. END SUB
  864.  
  865. SUB spaceindex
  866. SHARED colors, ne
  867. CLS
  868. LOCATE 10, 1
  869. DO WHILE we > ne OR we < 1
  870. INPUT "Greatest element number adjoining space: ", we
  871. LOOP
  872. wn = 2 * we - 2
  873. CLS
  874. LOCATE 10
  875. PRINT "     Choose medium: "
  876. PRINT " "
  877. PRINT "     1> Air"
  878. PRINT "     2> Vacuum"
  879. PRINT "     3> Water"
  880. PRINT "     4> Other"
  881. PRINT ""
  882. INPUT "     Choice: ", L
  883. SELECT CASE L
  884.     CASE 1
  885.         n = 1.0003
  886.     CASE 2
  887.         n = 1!
  888.     CASE 3
  889.         n = 4 / 3
  890.     CASE 4
  891.         INPUT "Index of refraction: ", n
  892.     CASE ELSE
  893.         RETURN
  894. END SELECT
  895. FOR i = 1 TO colors
  896.     n(wn, i) = n
  897. NEXT i
  898. END SUB
  899.  
  900.